home *** CD-ROM | disk | FTP | other *** search
/ Macwelt 1 / Macwelt DVD 1.toast / Web-Publishing / HTML-Editoren / Alpha ƒ / Tcl / SystemCode / coreFixes.tcl < prev    next >
Encoding:
Text File  |  2001-02-01  |  34.3 KB  |  1,247 lines
  1. ## -*-Tcl-*-
  2.  # ###################################################################
  3.  #  AlphaTcl - core Tcl engine
  4.  # 
  5.  #  FILE: "coreFixes.tcl"
  6.  #                                    created: 31/7/97 {2:09:16 am} 
  7.  #                                last update: 02/01/2001 {10:28:32 AM} 
  8.  #  Author: Vince Darley
  9.  #  E-mail: <vince@santafe.edu>
  10.  #    mail: 317 Paseo de Peralta, Santa Fe, NM 87501
  11.  #     www: <http://www.santafe.edu/~vince/>
  12.  #  
  13.  # Reorganisation carried out by Vince Darley with much help from Tom 
  14.  # Fetherston, Johan Linde and suggestions from the Alpha-D mailing list.  
  15.  # Alpha is shareware; please register with the author using the register 
  16.  # button in the about box.
  17.  #  
  18.  # This file contains Tcl procs which wrap around or replace
  19.  # core (hard-coded) Alpha procs to fix some bugs they may have.
  20.  # Sadly most core Alpha bugs can't be fixed in this way.
  21.  # 
  22.  # Ultimately, one hopes, these bugs will be fixed and these procs
  23.  # can be removed...
  24.  # ###################################################################
  25.  ##
  26.  
  27. # ◊◊◊◊ Buggy procs ◊◊◊◊ #
  28.  
  29. if {[info exists alpha::gotCoreFixes]} {
  30.     return
  31. }
  32.  
  33. if {[info tclversion] < 8.0} {
  34.     # Replicates some of the functionality of Tcl 8's 'foreach' command.
  35.     proc newforeach {vars vals script} {
  36.     set _for_index 0
  37.     while {$_for_index < [llength $vals]} {
  38.         foreach var $vars {
  39.         set val [lindex $vals $_for_index]
  40.         incr _for_index
  41.         uplevel 1 [list set $var $val]
  42.         }
  43.         uplevel 1 $script
  44.     }
  45.     }
  46. } else {
  47.     # Wrap around Tcl 8's foreach
  48.     proc newforeach {args} { uplevel 1 foreach $args }
  49. }
  50.  
  51. if {[info tclversion] < 8.0} {
  52.     proc ensureTextWasColoured {pos t} {
  53.     if {[set nlines [llength [split $t "\r"]]] > 1} {
  54.         goto $pos
  55.         for {set n 2} {$n <= $nlines} {incr n} {
  56.         goto [nextLineStart [getPos]]
  57.         replaceText [getPos] [getPos] ""
  58.         undo
  59.         }
  60.     }
  61.     }
  62. } else {
  63.     # We'll fix this in Alpha 8
  64.     proc ensureTextWasColoured {pos t} {}
  65. }
  66.  
  67.  
  68. namespace eval status {}
  69. if {[info commands status::flash] == ""} {
  70.     proc status::flash {color} {
  71.     # not implemented
  72.     }
  73. }
  74.  
  75. if {[info commands status::msg] == ""} {
  76.     # 'message' conflicts with Tk, so we should gradually transition
  77.     # away from that to 'status::msg'.
  78.     proc status::msg {text} {
  79.     message $text
  80.     }
  81. }
  82.  
  83. if {[info tclversion] < 8.0} {
  84.     proc status::prompt {args} {
  85.     set opts(-add) key
  86.     getOpts {-command -add -appendvar}
  87.     switch -- [llength $args] {
  88.         default {
  89.         error "status::prompt ?-f -add what -command script -appendvar var?\
  90.           prompt ?oldfunc? ?add?"
  91.         }
  92.         1 {
  93.         set prompt [lindex $args 0]
  94.         set func ""
  95.         }
  96.         2 {
  97.         newforeach {prompt func} $args {}
  98.         }
  99.         3 {
  100.         newforeach {prompt func opts(-add)} $args {}
  101.         }
  102.     }
  103.     if {[info exists opts(-f)]} {
  104.         status::flash black
  105.     }
  106.     global status::proc status::add status::oldstyle
  107.     if {[info exists func] && [string length $func]} {
  108.         set status::oldstyle 1
  109.     } else {
  110.         set func $opts(-command)
  111.         set status::oldstyle 0
  112.     }
  113.     set status::proc $func
  114.     set status::add $opts(-add)
  115.  
  116.     set thePrompt $prompt
  117.     while {1} {
  118.         set err [catch [list uplevel [list statusPrompt $thePrompt status::helper]] res]
  119.         # tclLog "\r$err $res"
  120.         if {$err == 1} {
  121.         if {$res == ""} {
  122.             # Assume a backspace
  123.             uplevel [list status::helper "" "\010"]
  124.             # Since we are going to re-enter 'statusPrompt, we have to
  125.             # adjust the initial prompt to display the current search string.
  126.             if {[info exists opts(-appendvar)]} {
  127.             upvar $opts(-appendvar) pat
  128.             set thePrompt "${prompt}${pat}"
  129.             } else {
  130.             set thePrompt $prompt
  131.             }
  132.             continue
  133.         }
  134.         }
  135.         return -code $err $res
  136.     }
  137.     }
  138.  
  139.     proc status::helper {args} {
  140.     global status::add status::proc status::oldstyle
  141.     switch -- ${status::add} {
  142.         "modifiers" -
  143.         "anything" {
  144.         lappend args [getModifiers]
  145.         } 
  146.     }
  147.     if {${status::oldstyle}} {
  148.         return [uplevel 1 ${status::proc} $args]
  149.     } else {
  150.         return [uplevel 1 ${status::proc} [lrange $args 1 end]]
  151.     }
  152.     }
  153. } else {
  154. ## 
  155.  # -------------------------------------------------------------------------
  156.  # 
  157.  # "status::prompt" --
  158.  # 
  159.  #  This is a more useful and generally more powerful replacement for the
  160.  #  built in 'statusPrompt'.  It gives the caller more control and
  161.  #  flexibility about a variety of actions (especially 'delete' keys),
  162.  #  while trying to place as little burden on the caller as possible.
  163.  #  
  164.  #  If you wish to query modifier key presses too, the current getModifier
  165.  #  key status can be appended to the command script too.
  166.  #  
  167.  #  There are basically two ways of calling this procedure:
  168.  #  
  169.  #  (i) old style 'status::prompt ?-f? promptText ?promptFunc? ?add?'
  170.  #  
  171.  #  see the documentation of statusPrompt for this case; it is very
  172.  #  similar.  The given function is called with a few arguments appended,
  173.  #  the old string, the new char, and possibly the getModifier status.
  174.  #  
  175.  #  (ii) new style 'status::prompt ?-f? ?-add what? ?-command script? prompt'
  176.  #  
  177.  #  In this case, the command script is expected to keep track of the
  178.  #  current prompt, and so the command script is evaluated with only 1 or 2
  179.  #  arguments appended: the new character pressed, and optional the getModifier
  180.  #  status.
  181.  #  
  182.  #  An optional -debug flag can be used to 'tclLog' the command lines used,
  183.  #  and results from calling the command script.
  184.  #  
  185.  #  For compatibility with Alphatk, you must not call 'getModifiers' yourself,
  186.  #  but should use the optional '-add' argument. ('-add anything' is usual).
  187.  #  
  188.  # -------------------------------------------------------------------------
  189.  ##
  190.     proc status::prompt {args} {
  191.     set opts(-add) key
  192.     getOpts {-command -add -appendvar}
  193.     switch -- [llength $args] {
  194.         default {
  195.         error "status::prompt ?-f -add what -command script -appendvar var?\
  196.           prompt ?oldfunc? ?add?"
  197.         }
  198.         1 {
  199.         set prompt [lindex $args 0]
  200.         set func ""
  201.         }
  202.         2 {
  203.         foreach {prompt func} $args {}
  204.         }
  205.         3 {
  206.         foreach {prompt func opts(-add)} $args {}
  207.         }
  208.     }
  209.     if {[info exists opts(-f)]} {
  210.         status::flash black
  211.     }
  212.     if {[info exists func] && [string length $func]} {
  213.         set oldstyle 1
  214.     } else {
  215.         set func $opts(-command)
  216.         set oldstyle 0
  217.     }
  218.     set thePrompt $prompt
  219.     message $thePrompt
  220.     set statuscontents ""
  221.     while {1} {
  222.         if {!$oldstyle} {
  223.         set statuscontents ""
  224.         }
  225.         set res [coreKeyPrompt $thePrompt]
  226.         set args {}
  227.         if {$oldstyle} {
  228.         lappend args $statuscontents
  229.         }
  230.         lappend args [lindex $res 0]
  231.         switch -- $opts(-add) {
  232.         "modifiers" -
  233.         "anything" {
  234.             lappend args [lindex $res 1]
  235.         }
  236.         }
  237.         if {[info exists opts(-debug)]} {
  238.         tclLog "$func $args"
  239.         }
  240.         if {[set err [catch [list uplevel 1 $func $args] res]]} {
  241.         if {[info exists opts(-debug)]} {
  242.             global errorInfo
  243.             tclLog "$err $res $errorInfo"
  244.         }
  245.         return -code $err $res
  246.         }
  247.         if {$oldstyle} {
  248.         if {[info exists opts(-debug)]} {
  249.             tclLog "Returned: $res"
  250.         }
  251.         if {$res == ""} {
  252.             return $statuscontents
  253.         }
  254.         }
  255.         if {[info exists opts(-appendvar)]} {
  256.         upvar $opts(-appendvar) pat
  257.         set thePrompt "${prompt}${pat}"
  258.         } else {
  259.         set thePrompt $prompt
  260.         if {$oldstyle} {
  261.             append statuscontents $res
  262.             message "$thePrompt$statuscontents"
  263.         }
  264.         }
  265.     }
  266.     }
  267.     # Alpha 8 has 'betterStatusPrompt' which is both simpler and far more robust.
  268.     if {[info commands coreKeyPrompt] == ""} {
  269.     proc coreKeyPrompt {thePrompt} {
  270.         set err [catch [list betterStatusPrompt $thePrompt] res]
  271.         if {!$err} {
  272.         lappend args [lindex $res 1] [getModifiers]
  273.         return $args
  274.         } else {
  275.         if {[lindex $res 0] == 1} {
  276.             return -code $err "mouse click"
  277.         } else {
  278.             return -code $err [lindex $res 0]
  279.         }
  280.         }
  281.     }
  282.     }
  283. }
  284.  
  285. # so any selections present are maintained
  286. rename centerRedraw __centerRedraw
  287. ;proc centerRedraw {args} {
  288.     lappend selectionEndPoints [getPos] [selEnd]
  289.     uplevel __centerRedraw $args
  290.     eval select $selectionEndPoints 
  291. }
  292.  
  293. proc winIsFile {name} {
  294.     return [expr {[file exists $name] || \
  295.       ([regsub { <[0-9]+>$} $name {} name] && [file exists $name])}]
  296. }
  297.  
  298. if {![llength [info commands placeText]]} {
  299.     proc placeText {pos text args} {
  300.     if {$pos == "-w"} {
  301.         set w $text
  302.         set pos [lindex $args 0]
  303.         set text [lindex $args 1]
  304.         lappend selectionEndPoints [getPos -w $w] [selEnd -w $w]
  305.         replaceText -w $w $pos $pos $text
  306.         eval select -w [list $w] $selectionEndPoints 
  307.     } else {
  308.         lappend selectionEndPoints [getPos] [selEnd]
  309.         replaceText $pos $pos $text
  310.         eval select $selectionEndPoints 
  311.     }
  312.     }
  313. }
  314.  
  315. # so any selections present are maintained
  316. rename insertToTop __insertToTop
  317. ;proc insertToTop {args} {
  318.     lappend selectionEndPoints [getPos] [selEnd]
  319.     uplevel __insertToTop $args
  320.     eval select $selectionEndPoints 
  321. }
  322.  
  323. # not really a 'fix', but it's much more efficient in many places if
  324. # you can set the mode of a window in advance  ---- else you switch
  325. # modes twice on opening the window!  This version of 'new' has a new
  326. # flag '-m' which lets you set the mode.  It also returns the name
  327. # of the window which was really opened.  Any additional flags received
  328. # by this proc are assumed to be arguments to be passed to 'setWinInfo',
  329. # except without the leading '-'.  So, for instance you can do:
  330. #     new -n "blah" -tabsize 4 -shell 1
  331. # Also args '-text' to set the text, or a useful new flag '-info'
  332. # which takes the text as the next arg, and automatically sets the
  333. # window to a read-only shell window, and scrolls to the top after
  334. # inserting the given text.  Useful for all those 'info' windows Alpha
  335. # uses!
  336. rename new __new
  337. ;proc new {args} {
  338.     set i 0
  339.     set where {}
  340.     while {[set arg [lindex $args $i]] != ""} {
  341.     incr i
  342.     switch -- $arg {
  343.         "-n" { 
  344.         set name [lindex $args $i]
  345.         incr i
  346.         }
  347.         "-g" { 
  348.         eval lappend where "-g" [lrange $args $i [incr i 3]]
  349.         incr i
  350.         }
  351.         "-m" { 
  352.         set mode [lindex $args $i]
  353.         set mi $i
  354.         incr i
  355.         }
  356.         default {
  357.         set other($arg) [lindex $args $i]
  358.         incr i
  359.         }
  360.     }
  361.     }
  362.     if {![info exists name]} {
  363.     set name "Untitled"
  364.     }
  365.     if {[info tclversion] < 8.0} {
  366.     # Alpha can't cope with colons in names
  367.     regsub -all : $name . name
  368.     }
  369.     set newname $name
  370.     
  371.     if {[lsearch -exact [winNames] $name] != -1} {
  372.     set i 2
  373.     while {[lsearch -exact [winNames] "$name <$i>"] != -1} {
  374.         incr i
  375.     }
  376.     append name " <${i}>"
  377.     }
  378.     if {![info exists mode]} {
  379.     set mode [win::FindMode $newname]
  380.     }
  381.     # This will handle a mode-specific tab size, provided
  382.     # Alpha 8/tk call winCreatedHook at the appropriate time.
  383.     win::setInitialMode $name $mode
  384.     
  385.     if {[info tclversion] < 8.0} {
  386.     # In this section, we want to see if we need to temporally shadow out
  387.     # the global tabSize value with another value so as to avoid having to
  388.     # monkey with the winInfo array after the creation of the window
  389.     global tabSize ${mode}modeVars global::_oldTabSize
  390.     if {[info exists other(-tabsize)]} {
  391.         set global::_oldTabSize $tabSize 
  392.         set tabSize $other(-tabsize) 
  393.         unset other(-tabsize)
  394.     } elseif {[info exists ${mode}modeVars(tabSize)]} {
  395.         # The mode that the new window will open up in
  396.         # has its own value tabSize
  397.         set global::_oldTabSize $tabSize 
  398.         set tabSize [set ${mode}modeVars(tabSize)]
  399.     }
  400.     } else {
  401.     if {[info exists other(-tabsize)]} {
  402.         win::setInitialConfig $name tabsize $other(-tabsize)
  403.     }
  404.     }
  405.  
  406.     global alpha::platform
  407.     if {${alpha::platform} != "alpha"} {
  408.     eval __new -n [list $name] $where
  409.     } else {
  410.     eval __new -n [list $newname] $where
  411.     }
  412.     if {![info exists mode]} { 
  413.     set name [win::Current]
  414.     }
  415.     if {[info exists other(-info)]} {
  416.     setWinInfo -w $name shell 1
  417.     insertText $other(-info)
  418.     setWinInfo -w $name read-only 1
  419.     goto [minPos]
  420.     unset other(-info)
  421.     }
  422.     # We must do shell first, then text, then dirty and then others
  423.     # in any order.  Else we'd get errors like can't make window read-only
  424.     # when dirty if they were in the wrong order...
  425.     if {[info exists other(-shell)]} {
  426.     setWinInfo -w $name shell $other(-shell)
  427.     unset other(-shell)
  428.     }
  429.     if {[info exists other(-text)]} {
  430.     insertText $other(-text)
  431.     unset other(-text)
  432.     }
  433.     if {[info exists other(-dirty)]} {
  434.     setWinInfo -w $name dirty $other(-dirty)
  435.     unset other(-dirty)
  436.     }
  437.     if {[info exists other]} {
  438.     foreach a [array names other] {
  439.         setWinInfo -w $name [string range $a 1 end] $other($a)
  440.     }
  441.     }
  442.     return $name 
  443. }
  444.  
  445. # Not really a fix, but adds features much needed by glob, which otherwise
  446. # force one to write nasty code.  Vince's C implementation of this is
  447. # now in the core of Tcl (8.3 or newer).
  448.  
  449. ## 
  450.  # ------------------------------------------------------------------
  451.  # 
  452.  # "glob" --
  453.  # 
  454.  # Backwards compatible extensions to the 'glob' command to address
  455.  # some current issues:
  456.  # 
  457.  # 'file join' is incompatible with backslash-quoted directory paths,
  458.  # so it is very difficult to deal with paths containing
  459.  # glob-sensitive characters in a cross-platform way.  E.g. the user
  460.  # selects a directory in a directory-chooser, and I wish to find (i)
  461.  # all html files in that directory; (ii) all html files in any
  462.  # sub-directory of that directory; (iii) all subdirectories of that
  463.  # directory which contain the word 'hello'.  With the new glob, this
  464.  # can be achieved in a simple, cross-platform way as follows:
  465.  # 
  466.  # (i) 
  467.  # 
  468.  # set dir [tk_chooseDirectory]
  469.  # set html_files [glob -dir $dir *.html]
  470.  # 
  471.  # (ii)
  472.  # 
  473.  # set dir [tk_chooseDirectory]
  474.  # set sub_dir_html_files [glob -join -dir $dir * *.html]
  475.  # 
  476.  # (iii)
  477.  # 
  478.  # set dir [tk_chooseDirectory]
  479.  # set sub_dirs [glob -types d -dir $dir *hello*]
  480.  # 
  481.  # These will work even if '$dir' contains []{}*+\?  characters,
  482.  # which would be difficult to achieve using the old glob, without
  483.  # explicit backslash quoting of 'dir', and without explicit use of
  484.  # the current platform's directory separator (':' on MacOS,
  485.  # backslash or forward slash on other platforms).  Using this
  486.  # version of glob has allowed me to simplify otherwise messy code,
  487.  # and remove bugs caused by user-selected paths containing bad
  488.  # characters.
  489.  # 
  490.  # Syntax:
  491.  #   
  492.  #   glob ?switches? name ?name ...?
  493.  #   
  494.  # Switches:
  495.  # 
  496.  #   -nocomplain:   if no files are found, return an empty string, rather
  497.  #                  than signal an error.
  498.  #     
  499.  #   -join:         the remaining 'name' arguments are treated as 
  500.  #                  a path specification to be handled with 'file
  501.  #                  join'.
  502.  #                  
  503.  #   -dir <pat>:    search for patterns starting in this directory
  504.  #                  
  505.  #   -path <path>:  search for patterns starting with this path
  506.  #                  prefix (i.e. a directory and a file prefix).
  507.  #   
  508.  #   -types <list of types>: only list files/directories of one of
  509.  #                  the types listed.  Currently only type 'd' is
  510.  #                  supported, which lists only directories (hence
  511.  #                  avoiding the need to specify a platform specific
  512.  #                  separator char), but in the future, more types
  513.  #                  (possibly platform specific) will be supported:
  514.  #                  e.g. on MacOS types such as 'TEXT', 'APPL' will be
  515.  #                  supported.  Unrecognised types are ignored by glob.
  516.  #   
  517.  #   --             signals the end of switches, even if the next 
  518.  #                  argument starts with a '-'.
  519.  # 
  520.  # Each name argument is handled separately, unless '-join' is
  521.  # present.  Note the the '-dir' and '-path' flags are mutually
  522.  # exclusive.
  523.  # 
  524.  # The Tcl version below should work with Tcl8.0 or newer.  It
  525.  # requires a helper procedure 'getOpts' which follows.  Obviously if
  526.  # it meets with general approval it should be re-implemented in C.
  527.  # 
  528.  # --Version--Author------------------Changes-----------------------
  529.  #    1.0     vince@biosgroup.com original
  530.  # -----------------------------------------------------------------
  531.  ##
  532. if {[info tclversion] >= 8.0} {
  533.     # Tcl 8.3 or newer have a more complex glob already.
  534.     if {[info tclversion] < 8.3} {
  535.     # we've copied this here from stringsLists.tcl to avoid some
  536.     # bad auto-loading problems if there are early startup errors.
  537.     ;proc getOpts {{take_value ""} {set "set"}} {
  538.         upvar args a
  539.         upvar opts o
  540.         while {[string match \-* [set arg [lindex $a 0]]]} {
  541.         set a [lreplace $a 0 0]
  542.         if {$arg == "--"} {
  543.             return
  544.         } else {
  545.             if {[set idx [lsearch -regexp $take_value \
  546.               "^-?[string range $arg 1 end]( .*)?$"]] == -1} {
  547.             set o($arg) 1
  548.             } else {
  549.             if {[llength [set the_arg \
  550.               [lindex $take_value $idx]]] == 1} {
  551.                 $set o($arg) [lindex $a 0]
  552.                 set a [lreplace $a 0 0]
  553.             } else {
  554.                 set numargs [expr {[lindex $the_arg 1] -1}]
  555.                 $set o($arg) [lrange $a 0 $numargs]
  556.                 set a [lreplace $a 0 $numargs]
  557.             }
  558.             }
  559.         }
  560.         }
  561.     }
  562.     rename glob __glob
  563.     ;proc glob {args} {
  564.         getOpts {-tails -t -types -type -dir -path}
  565.         # place platform specific file separator in variable 'separator's
  566.         regexp {Z(.)Z} [file join Z Z] "" separator
  567.         if {[info exists opts(-join)]} {
  568.         unset opts(-join)
  569.         set args [list [eval file join $args]]
  570.         }
  571.         set add ""
  572.         foreach t {t type} {
  573.         if {[info exists opts(-$t)]} {
  574.             eval lappend opts(-types) $opts(-$t)
  575.             unset opts(-$t)
  576.         }
  577.         }
  578.         if {[info exists opts(-types)]} {
  579.         if {[set item [lsearch -exact $opts(-types) "d"]] != -1} {
  580.             set opts(-types) [lreplace $opts(-types) $item $item]
  581.             set add $separator
  582.             set isdirectory 1
  583.         }
  584.         }
  585.         if {[set nocomplain [info exists opts(-nocomplain)]]} {
  586.         unset opts(-nocomplain)
  587.         }
  588.         if {[info exists opts(-path)]} {
  589.         if {[info exists opts(-dir)]} {
  590.             if {$nocomplain} {
  591.             return ""
  592.             } else {
  593.             error "Can't use option '-dir' with '-path'"
  594.             }
  595.         }
  596.         regsub -all {[][*?\{\}\\]} $opts(-path) {\\&} prefix
  597.         unset opts(-path)
  598.         } elseif {[info exists opts(-dir)]} {
  599.         regsub -all {[][*?\{\}\\]} $opts(-dir) {\\&} prefix
  600.         append prefix ${separator}
  601.         unset opts(-dir)
  602.         } else {
  603.         set prefix ""
  604.         }
  605.         set res {}
  606.         foreach arg $args {
  607.         eval lappend res [__glob -nocomplain -- \
  608.           "${prefix}${arg}${add}"]
  609.         }
  610.         if {[info exists opts(-types)]} {
  611.         # we ignore arguments to -types which haven't yet been
  612.         # handled, since they are assumed to be platform
  613.         # specific
  614.         unset opts(-types)
  615.         }
  616.         if {[set llen [llength [array names opts]]]} {
  617.         set ok "-nocomplain, -join, -dir <dir>,\
  618.           -path <path>, -types <list of types>"
  619.         if {$llen > 1} {
  620.             error "bad switches \"[array names opts]\":\
  621.               must be $ok or --"
  622.         } else {
  623.             error "bad switch \"[array names opts]\":\
  624.               must be $ok or --"
  625.         }
  626.         } elseif {[llength $res]} {
  627.         if {[info exists isdirectory]} {
  628.             foreach r $res {
  629.             lappend newres [string trimright $r $separator]
  630.             }
  631.             return $newres
  632.         } else {
  633.             return $res
  634.         }
  635.         } elseif {$nocomplain} {
  636.         return ""
  637.         } else {
  638.         switch -- [llength $args] {
  639.             0 {
  640.             error "wrong # args: should be \"glob ?switches?\
  641.               name ?name ...?\""
  642.             }
  643.             1 {
  644.             error "no files matched glob pattern \"$args\""
  645.             }
  646.             default {
  647.             error "no files matched glob patterns \"$args\""
  648.             }
  649.         }
  650.         }
  651.     }
  652.     }
  653.  
  654. } else {
  655.     # we've copied this here from stringsLists.tcl to avoid some
  656.     # bad auto-loading problems if there are early startup errors.
  657.     ;proc getOpts {{take_value ""} {set "set"}} {
  658.     upvar args a
  659.     upvar opts o
  660.     while {[string match \-* [set arg [lindex $a 0]]]} {
  661.         set a [lreplace $a 0 0]
  662.         if {$arg == "--"} {
  663.         return
  664.         } else {
  665.         if {[set idx [lsearch -regexp $take_value \
  666.           "^-?[string range $arg 1 end]( .*)?$"]] == -1} {
  667.             set o($arg) 1
  668.         } else {
  669.             if {[llength [set the_arg \
  670.               [lindex $take_value $idx]]] == 1} {
  671.             $set o($arg) [lindex $a 0]
  672.             set a [lreplace $a 0 0]
  673.             } else {
  674.             set numargs [expr {[lindex $the_arg 1] -1}]
  675.             $set o($arg) [lrange $a 0 $numargs]
  676.             set a [lreplace $a 0 $numargs]
  677.             }
  678.         }
  679.         }
  680.     }
  681.     }
  682.     rename glob __glob
  683.     ;proc glob {args} {
  684.     getOpts {-tails -t -types -type -dir -path}
  685.     # place platform specific file separator in variable 'separator's
  686.     regexp {Z(.)Z} [file join Z Z] "" separator
  687.     if {[info exists opts(-join)]} {
  688.         unset opts(-join)
  689.         set args [list [eval file join $args]]
  690.     }
  691.     set add ""
  692.     foreach t {t type} {
  693.         if {[info exists opts(-$t)]} {
  694.         eval lappend opts(-types) $opts(-$t)
  695.         unset opts(-$t)
  696.         }
  697.     }
  698.     if {[info exists opts(-types)]} {
  699.         if {[set item [lsearch -exact $opts(-types) "d"]] != -1} {
  700.         set opts(-types) [lreplace $opts(-types) $item $item]
  701.         set add $separator
  702.         set isdirectory 1
  703.         }
  704.     }
  705.     if {[set nocomplain [info exists opts(-nocomplain)]]} {
  706.         unset opts(-nocomplain)
  707.     }
  708.     if {[info exists opts(-path)]} {
  709.         if {[info exists opts(-dir)]} {
  710.         if {$nocomplain} {
  711.             return ""
  712.         } else {
  713.             error "Can't use option '-dir' with '-path'"
  714.         }
  715.         }
  716.         if {[regexp {^(\.|:)} $opts(-path)]} {
  717.         set opts(-path) "[pwd][string range $opts(-path) 1 end]"
  718.         }
  719.         regsub -all {[][*?\{\}\\]} $opts(-path) {\\&} prefix
  720.         unset opts(-path)
  721.     } elseif {[info exists opts(-dir)]} {
  722.         if {[regexp {^(\.|:)} $opts(-dir)]} {
  723.         set opts(-dir) [string trimright [pwd][string range $opts(-dir) 1 end] ":"]
  724.         }
  725.         regsub -all {[][*?\{\}\\]} $opts(-dir) {\\&} prefix
  726.         append prefix ${separator}
  727.         unset opts(-dir)
  728.     } else {
  729.         set prefix ""
  730.     }
  731.     set glob_args [list -nocomplain]
  732.     if {[info exists opts(-types)]} {
  733.         foreach pair $opts(-types) {
  734.         set type [lindex $pair 0]
  735.         if {$type != "" && $type != "*"} {
  736.             if {[string length $type] == 4} {
  737.             lappend glob_args -t $type
  738.             } else {
  739.             lappend old_t $pair
  740.             continue
  741.             }
  742.         }
  743.         if {[llength $pair] > 1} {
  744.             # it's a MacOS 'type crea' pair
  745.             set crea [lindex $pair 1]
  746.             if {$crea != "" && $crea != "*"} {
  747.             if {[string length $crea] == 4} {
  748.                 lappend glob_args -c $crea
  749.             } else {
  750.                 lappend old_t $pair
  751.                 continue
  752.             }
  753.             }
  754.         } 
  755.         }
  756.         unset opts(-types)
  757.         if {[info exists old_t]} {
  758.         set opts(-types) $old_t
  759.         }
  760.     }
  761.     set res {}
  762.     foreach arg $args {
  763.         eval lappend res [eval __glob $glob_args -- \
  764.           [list "${prefix}${arg}${add}"]]
  765.     }
  766.     if {[info exists opts(-types)]} {
  767.         # we ignore arguments to -types which haven't yet been
  768.         # handled, since they are assumed to be platform specific
  769.         unset opts(-types)
  770.     }
  771.     if {[set llen [llength [array names opts]]]} {
  772.         set ok "-nocomplain, -join, -dir <dir>,\
  773.           -path <path>, -types <list of types>"
  774.         if {$llen > 1} {
  775.         error "bad switches \"[array names opts]\":\
  776.           must be $ok or --"
  777.         } else {
  778.         error "bad switch \"[array names opts]\":\
  779.           must be $ok or --"
  780.         }
  781.     } elseif {[llength $res]} {
  782.         if {[info exists isdirectory]} {
  783.         foreach r $res {
  784.             lappend newres [string trimright $r $separator]
  785.         }
  786.         return $newres
  787.         } else {
  788.         return $res
  789.         }
  790.     } elseif {$nocomplain} {
  791.         return ""
  792.     } else {
  793.         switch -- [llength $args] {
  794.         0 {
  795.             error "wrong # args: should be \"glob ?switches?\
  796.               name ?name ...?\""
  797.         }
  798.         1 {
  799.             error "no files matched glob pattern \"$args\""
  800.         }
  801.         default {
  802.             error "no files matched glob patterns \"$args\""
  803.         }
  804.         }
  805.     }
  806.     }
  807. }
  808.  
  809. # If the position to blink is offscreen, show a message with context
  810. rename blink __blink
  811. ;proc blink {pos} {
  812.     __blink $pos
  813.     getWinInfo w
  814.     if {[info exists w(currline)]} {
  815.     set topl $w(currline)
  816.     set endl [expr {$topl + $w(linesdisp)}]
  817.     scan [posToRowCol $pos] "%d %d" row col
  818.     if {$row < $topl || $row >= $endl} {
  819.         message "Matching '[getText [lineStart $pos] [pos::math $pos + 1]]'"
  820.     }
  821.     }
  822. }
  823.  
  824. if {[info tclversion] >= 8.0} {
  825.     # This will work with Alpha 7, although at the expense of changing
  826.     # the file dialog somewhat, so we deactivate it there.  You can simply
  827.     # copy this into your prefs.tcl if you want to use it with Alpha 7.
  828. proc findFile {args} {
  829.     set filename [eval [list getfile "Open which file:"] $args]
  830.     edit $filename
  831. }
  832. }
  833.  
  834. if {[set alpha::platform] == "alpha"} {
  835.     if {[info commands edit] == ""} {
  836.     ;proc edit {args} {
  837.         set resize 0
  838.         set marksMenuOnly 0
  839.         
  840.         set newWinAsk 1
  841.         set readOnlyAsk 1
  842.         set wrapAsk 1
  843.         
  844.         set parameters {}
  845.         
  846.         set i 0
  847.         while {[set arg [lindex $args $i]] != ""} {
  848.         switch -- $arg {
  849.             "-tabsize" {
  850.             set tabsize [lindex $args [incr i]]
  851.             set args [lreplace $args [expr {$i-1}] $i]
  852.             incr i -1
  853.             }
  854.             "-c" {
  855.             set newWinAsk 0
  856.             lappend parameters NewW no
  857.             set args [lreplace $args $i $i]
  858.             }
  859.             "-g" {
  860.             set resize 1
  861.             set left [lindex $args [incr i]]
  862.             set top [lindex $args [incr i]]
  863.             set width [lindex $args [incr i]]
  864.             set height [lindex $args [incr i]]
  865.             set args [lreplace $args [expr {$i-4}] $i]
  866.             incr i -4
  867.             }
  868.             "-m" {
  869.             set marksMenuOnly 1
  870.             }
  871.             "-r" {
  872.             set readOnlyAsk 0
  873.             lappend parameters perm no
  874.             set args [lreplace $args $i $i]
  875.             }
  876.             "-w" {
  877.             set wrapAsk 0
  878.             lappend parameters Wrap no
  879.             set args [lreplace $args $i $i]
  880.             }
  881.             "--" {
  882.             set args [lreplace $args $i $i]
  883.             break
  884.             }
  885.             default {
  886.             break
  887.             }
  888.         }
  889.         }
  890.         
  891.         if {$newWinAsk} {
  892.         lappend parameters NewW ask
  893.         } 
  894.         if {$readOnlyAsk} {
  895.         lappend parameters perm ask
  896.         }
  897.         if {$wrapAsk} {
  898.         lappend parameters Wrap ask
  899.         }
  900.         
  901.         if {[set path [lindex $args $i]] == ""} {
  902.         error "No file name specified for edit"
  903.         }
  904.         
  905.         lappend parameters ---- [tclAE::build::alis $path]
  906.         
  907.         eval tclAE::send -s -dr aevt odoc $parameters
  908.         
  909.         if {[info exists tabsize]} {
  910.         setWinInfo tabsize $tabsize
  911.         }
  912.         
  913.         if {$resize} {
  914.         moveWin $left $top
  915.         sizeWin $width $height
  916.         }
  917.  
  918.         if {$marksMenuOnly} {
  919.         setWinInfo marksMenuOnly 1
  920.         }
  921.     }
  922.     } else {
  923.     rename edit __edit
  924.     ;proc edit {args} {
  925.         set i 0
  926.         while {[set arg [lindex $args $i]] != ""} {
  927.         incr i
  928.         switch -- $arg {
  929.             "-tabsize" {
  930.             set tabsize [lindex $args $i]
  931.             set args [lreplace $args [expr {$i-1}] $i]
  932.             incr i
  933.             }
  934.         }
  935.         }
  936.         if {[info exists tabsize]} {
  937.         global tabSize
  938.         set oldTabSize $tabSize
  939.         set tabSize $tabsize
  940.         # So we don't mangle the global tabSize
  941.         set err [catch [list uplevel 1 __edit $args] res]
  942.         set tabSize $oldTabSize
  943.         return -code $err $res
  944.         } else {
  945.         uplevel 1 __edit $args
  946.         }
  947.     }
  948.     }
  949.  
  950.     # keep window vertical position the same
  951.     rename revert __revert
  952.     if {[info tclversion] < 8.0} {
  953.     ;proc revert {args} {
  954.         if {[llength $args] && [lindex $args 0] == "-w"} {
  955.         set win [lindex $args 1]
  956.         getWinInfo -w $win w
  957.         set topl $w(currline)
  958.         bringToFront $win
  959.         uplevel __revert [lrange $args 2 end]
  960.         revertHook $win
  961.         display -w $win [rowColToPos -w $win $topl 0]
  962.         } else {
  963.         getWinInfo w
  964.         set topl $w(currline)
  965.         uplevel __revert $args
  966.         revertHook [win::Current]
  967.         display [rowColToPos $topl 0]
  968.         }
  969.     }
  970.     } else {
  971.     ;proc revert {args} {
  972.         if {[llength $args] && [lindex $args 0] == "-w"} {
  973.         set win [lindex $args 1]
  974.         } else {
  975.         set win [win::Current]
  976.         }
  977.         getWinInfo -w $win w
  978.         set topl $w(currline)
  979.         uplevel __revert $args
  980.         revertHook $win
  981.         display -w $win [rowColToPos -w $win $topl 0]
  982.     }
  983.     }
  984.     if {[info tclversion] < 8.0} {
  985.     # Works around the silly default of 3000 chars internal to Alpha
  986.     rename matchIt __matchIt
  987.     ;proc matchIt {args} {
  988.         if {[llength $args] == 2} {
  989.         # even though the extra argument is a number of characters
  990.         # we simply use maxPos because this is at least as big a
  991.         # number as we need.
  992.         lappend args [maxPos]
  993.         }
  994.         uplevel 1 __matchIt $args
  995.     }
  996.     }
  997. }
  998.  
  999. rename edit editDocument
  1000.  
  1001. ## 
  1002.  # -------------------------------------------------------------------------
  1003.  # 
  1004.  # "edit" --
  1005.  # 
  1006.  #  This is the start of the chain of events which AlphaTcl expects when
  1007.  #  Alpha/Alphatk is asked to 'open' a file.  That request may result
  1008.  #  in the file being opened, or, depending on procedures registered
  1009.  #  with 'editHook', a different action may be taken.  For example,
  1010.  #  installer files should avoid the whole 'edit' completely, non-text
  1011.  #  files could be ignored, and even more complex actions could be taken.
  1012.  #  For example, with the appropriate Tcl extensions, we can arrange for 
  1013.  #  the mounting of 'virtual file systems' (such as .tar, .sit or .zip
  1014.  #  files) when the archive is opened by Alpha (hence allowing transparent
  1015.  #  editing of their contents in place).  Even urls could be mounted in
  1016.  #  this way to provide an alternative method of editing files on remote
  1017.  #  ftp sites.
  1018.  #  
  1019.  #  Anyway, procedures registered to editHook should return 0
  1020.  #  if they took no action, or 1 if they accept resposibility for the
  1021.  #  file.  No other return values are permitted.  The 'mode' field
  1022.  #  of this hook is the file's extension.
  1023.  #  
  1024.  #  Extensions must be lowercase (in the hook::register call).  For
  1025.  #  example:
  1026.  #  
  1027.  #     hook::register editHook install::editHook .install
  1028.  #  
  1029.  #  In the future we will integrate this with the above implementations
  1030.  #  of edit so that we can, for instance, specify a flag to force Alpha
  1031.  #  to edit the file.
  1032.  # -------------------------------------------------------------------------
  1033.  ##
  1034. proc edit {args} {
  1035.     set filename [lindex $args end]
  1036.     if {![hook::callUntil editHook \
  1037.       [string tolower [file extension $filename]] $filename]} {
  1038.     eval editDocument $args
  1039.     }
  1040. }
  1041.  
  1042.  
  1043.  
  1044. namespace eval menu {}
  1045. rename insertMenu __insertMenu
  1046. rename removeMenu __removeMenu
  1047. ;proc insertMenu {m} {
  1048.     global menu::toplevels
  1049.     __insertMenu $m
  1050.     set menu::toplevels($m) 1
  1051. }
  1052. ;proc removeMenu {m} {
  1053.     global menu::toplevels
  1054.     __removeMenu $m
  1055.     set menu::toplevels($m) 0
  1056. }
  1057.  
  1058. proc menu::inserted {m} {
  1059.     global menu::toplevels
  1060.     if {[info exists menu::toplevels($m)]} {
  1061.     return [set menu::toplevels($m)]
  1062.     } else {
  1063.     return 0
  1064.     }
  1065. }
  1066.  
  1067. rename save __save
  1068. ;proc save {{name ""}} {
  1069.     global win::Modified win::Active
  1070.     if {$name == ""} {
  1071.     set name [lindex [set win::Active] 0]
  1072.     } elseif {[info tclversion] < 8.0} {
  1073.     bringToFront $name
  1074.     }
  1075.     set origName $name
  1076.     if {![file exists $name] && \
  1077.       !([regsub { <[0-9]+>$} $name {} name] && [file exists $name])} {
  1078.     if {[info exists win::Modified($origName)]} {
  1079.         if {![dialog::yesno "The file appears to have been moved\
  1080.           since it was last opened or saved.  Are you sure you\
  1081.           want to save it?"]} {
  1082.         error "Save aborted by user, since file appears to\
  1083.           have been moved."
  1084.         }
  1085.     }
  1086.     # It's a new window which has never been saved
  1087.     set isNew 1
  1088.     } else {
  1089.     getFileInfo $name info
  1090.     if {[info tclversion] < 8.0} {
  1091.         # We used the 'red disk icon' to save, which doesn't
  1092.         # call savePostHook.  We could call savePostHook now,
  1093.         # except that it could cause some weird problems if
  1094.         # any registered hooks do things the user only expects
  1095.         # to happen immediately after a save.
  1096.         if {![info exists win::Modified($origName)]} {
  1097.         set win::Modified($origName) $info(modified)
  1098.         }
  1099.     }
  1100.     if {[set win::Modified($origName)] < $info(modified)} {
  1101.         # File has changed on disk
  1102.         if {![dialog::yesno "This file has changed on disk.  Are you\
  1103.           sure you want to save it?"]} {
  1104.         error "Save aborted by user, since newer file existed."
  1105.         }
  1106.     }
  1107.     }
  1108.     if {[info tclversion] >= 8.0} {
  1109.     uplevel 1 [list __save $origName]
  1110.     } else {
  1111.     uplevel 1 __save
  1112.     # New windows don't get savePostHook called until Alpha 8, so
  1113.     # we have to do it manually 
  1114.     if {[info exists isNew]} {
  1115.         # The user may have cancelled the save
  1116.         set name [win::Current]
  1117.         if {[file exists $name] || \
  1118.           ([regsub { <[0-9]+>$} $name {} name] && [file exists $name])} {
  1119.         savePostHook [win::Current]
  1120.         }
  1121.     }
  1122.     }
  1123. }
  1124.  
  1125.  
  1126. rename print __print
  1127. ;proc print {args} {
  1128.     # make sure we've got our procs loaded, else Alpha can't print
  1129.     auto_load printLeftHeader
  1130.     auto_load printRightHeader
  1131.     if {[llength $args]} {
  1132.     if {[catch [list __print [lindex $args 0]]]} {
  1133.         file::openQuietly [lindex $args 0]
  1134.         bringToFront [lindex $args 0]
  1135.         uplevel __print
  1136.     } 
  1137.     } else {
  1138.     uplevel __print
  1139.     }
  1140. }
  1141.  
  1142. # Fixes two bugs: the message in the status window was incorrect (shows
  1143. # the search, not replace string).  Also a replace string of nothing was
  1144. # rejected.
  1145. if {[llength [info commands enterReplaceString]]} {rename enterReplaceString ""}
  1146. ;proc enterReplaceString {} {
  1147.     set t [getSelect]
  1148.     replaceString $t
  1149.     message "Entered replace '$t'"
  1150. }
  1151. # Doesn't fix any bugs, but forces enterSearchString to use the
  1152. # command 'searchString' rather than setting the string behind
  1153. # the scenes.
  1154. if {[llength [info commands enterSearchString]]} {rename enterSearchString ""}
  1155. ;proc enterSearchString {} {
  1156.     set t [getSelect]
  1157.     searchString $t
  1158.     message "Entered search '$t'"
  1159. }
  1160.  
  1161.  
  1162. # ◊◊◊◊ Procs fixed in Alpha 8 ◊◊◊◊ #
  1163.  
  1164. if {[info tclversion] >= 8.0} {
  1165.     # We just have this proc to help people who haven't updated their code
  1166.     # to use Tcl 8's native routines.  It will vanish eventually.
  1167.     ;proc mkdir {dir} {
  1168.     file mkdir $dir
  1169.     }
  1170.     return
  1171. }
  1172.  
  1173. rename saveAs __saveAs
  1174. ;proc saveAs {args} {
  1175.     uplevel __saveAs $args
  1176.     savePostHook [win::Current]
  1177. }
  1178.  
  1179. # old version is a bit picky
  1180. if {![string length [info commands __cd]]} {
  1181.     rename cd __cd
  1182. }
  1183. ;proc cd args {
  1184.     if {$args == ".."} { set args "::" }
  1185.     if {$args == "."} { set args ":" }
  1186.     if {[llength $args]} {
  1187.     set path [string trim [eval list $args] "        \{\}"]
  1188.     if {![regexp {:$} $path]} { append path ":" }
  1189.     if {![file isdirectory $path] && [file isdirectory [pwd]$path]} {
  1190.         set path ":$path"
  1191.     }
  1192.     __cd $path
  1193.     } else {
  1194.     global HOME
  1195.     __cd $HOME
  1196.     }
  1197. }
  1198.  
  1199. # fix for Alpha trapping command clicks on lines which contain ':'
  1200. # unnecessarily.
  1201. rename icURL __icURL
  1202. ;proc icURL {args} {
  1203.     if {[regexp  "^f(ile|tp)::" $args] || [catch {eval __icURL $args}]} {
  1204.     set mods [getModifiers]
  1205.     # Alpha highlights the wrong piece of text, so find mouse pos
  1206.     # and generate a new piece position
  1207.     if {![catch {mousePos} pos]} {
  1208.         goto [eval rowColToPos $pos]
  1209.     }
  1210.     cmdDoubleClick -1 -1 \
  1211.       [expr {$mods & 34}] [expr {$mods & 72}] [expr {$mods & 144}]
  1212.     }
  1213. }
  1214. # bring to front does nothing if already foremost 
  1215. # (the original calls activateHook, changeMode....)
  1216. rename bringToFront __bringToFront
  1217. ;proc bringToFront {name} {
  1218.     global win::Current
  1219.     if {[file tail $name] != [file tail ${win::Current}]} { 
  1220.     __bringToFront $name 
  1221.     }
  1222. }
  1223.  
  1224. # if you select a directory from inside it, it has a ':', if you select
  1225. # from outside, it doesn't have a colon.  There is another problem, which
  1226. # is that Alpha won't let you select a volume, only a folder within a 
  1227. # volume, but I haven't fixed that here.
  1228. rename get_directory __get_directory
  1229. ;proc get_directory {args} {
  1230.     set dir [eval __get_directory $args]
  1231.     regsub {:$} $dir {} dir
  1232.     return $dir
  1233. }
  1234.  
  1235.  
  1236. # Setting fonts and tabs doesn't need to dirty the window
  1237. rename setFontsTabs __setFontsTabs
  1238. ;proc setFontsTabs {args} {
  1239.     set d [winDirty]
  1240.     uplevel __setFontsTabs $args
  1241.     if {!$d && [winDirty]} {
  1242.     setWinInfo dirty 0
  1243.     }
  1244. }
  1245.  
  1246. set alpha::gotCoreFixes 1
  1247.